home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / time.lsp < prev    next >
Lisp/Scheme  |  1992-08-28  |  7KB  |  194 lines
  1. (in-package "PCL")
  2.  
  3. (proclaim '(optimize (speed 3)(safety 0)(compilation-speed 0)))
  4.  
  5. (defvar *tests*)
  6. (setq *tests* nil)
  7.  
  8. (defvar m (car (generic-function-methods #'shared-initialize)))
  9. (defvar gf #'shared-initialize)
  10. (defvar c (find-class 'standard-class))
  11.  
  12. (eval-when (compile)
  13.  (defvar *saved-defclass-times* *defclass-times*)
  14.  (setf *defclass-times* '(eval load compile)))
  15.  
  16. (defclass str ()
  17.   ((slot :initform nil :reader str-slot))
  18.   (:metaclass structure-class))
  19.  
  20. (eval-when (compile)
  21.  (setf *defclass-times* *saved-defclass-times*))
  22.  
  23. (defvar str (make-instance 'str))
  24.  
  25. (push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (standard)"
  26.         '(time-slot-value m 'plist 10000))
  27.       *tests*)
  28. (push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (standard)"
  29.         '(time-slot-value m 'generic-function 10000))
  30.       *tests*)
  31. (push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (structure)"
  32.         '(time-slot-value str 'slot 10000))
  33.       *tests*)
  34. (defun time-slot-value (object slot-name n)
  35.   (time (dotimes (i n) (slot-value object slot-name))))
  36.  
  37.  
  38. (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)"
  39.         '(time-slot-value-function m 10000))
  40.       *tests*)
  41. (defun time-slot-value-function (object n)
  42.   (time (dotimes (i n) (slot-value object 'function))))
  43.  
  44.  
  45. (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)"
  46.         '(time-slot-value-slot str 10000))
  47.       *tests*)
  48. (defun time-slot-value-slot (object n)
  49.   (time (dotimes (i n) (slot-value object 'slot))))
  50.  
  51.  
  52. (push (cons "Time one-class dfun."
  53.         '(time-generic-function-methods gf 10000))
  54.       *tests*)
  55. (defun time-generic-function-methods (object n)
  56.   (time (dotimes (i n) (generic-function-methods object))))
  57.  
  58.  
  59. (push (cons "Time one-index dfun."
  60.         '(time-class-precedence-list c 10000))
  61.       *tests*)
  62. (defun time-class-precedence-list (object n)
  63.   (time (dotimes (i n) (class-precedence-list object))))
  64.  
  65.  
  66. (push (cons "Time n-n dfun."
  67.         '(time-method-function m 10000))
  68.       *tests*)
  69. (defun time-method-function (object n)
  70.   (time (dotimes (i n) (method-function object))))
  71.  
  72.  
  73. (push (cons "Time caching dfun."
  74.         '(time-class-slots c 10000))
  75.       *tests*)
  76. (defun time-class-slots (object n)
  77.   (time (dotimes (i n) (class-slots object))))
  78.  
  79.  
  80. (push (cons "Time typep for classes."
  81.         '(time-typep-standard-object m 10000))
  82.       *tests*)
  83. (defun time-typep-standard-object (object n)
  84.   (time (dotimes (i n) (typep object 'standard-object))))
  85.  
  86.  
  87. (push (cons "Time default-initargs."
  88.         '(time-default-initargs (find-class 'plist-mixin) 1000))
  89.       *tests*)
  90. (defun time-default-initargs (class n)
  91.   (time (dotimes (i n) (default-initargs class nil (class-default-initargs class)))))
  92.  
  93.  
  94. (push (cons "Time make-instance."
  95.         '(time-make-instance (find-class 'plist-mixin) 1000))
  96.       *tests*)
  97. (defun time-make-instance (class n)
  98.   (time (dotimes (i n) (make-instance class))))
  99.  
  100.  
  101. (defmethod meth-no-slot-value ((object standard-method))
  102.   NIL)
  103.  
  104. (defmethod meth-standard-1-slot-value ((object standard-method))
  105.   (slot-value object 'function))
  106.  
  107. (defmethod meth-standard-2-slot-value ((object standard-method))
  108.   (values (slot-value object 'function)
  109.           (slot-value object 'optimized-function)))
  110.  
  111. (defmethod meth-structure-1-slot-value ((object str))
  112.   (slot-value object 'slot))
  113.  
  114. (push (cons "Time optimized defmethod without slot-value (standard)"
  115.         '(time-meth-no-slot-value m 10000))
  116.       *tests*)
  117. (defun time-meth-no-slot-value (object n)
  118.   (time (dotimes (i n) (meth-no-slot-value object))))
  119.  
  120. (push (cons "Time optimized slot-value inside of a defmethod (standard)"
  121.         '(time-meth-standard-1-slot-value m 10000))
  122.       *tests*)
  123. (defun time-meth-standard-1-slot-value (object n)
  124.   (time (dotimes (i n) (meth-standard-1-slot-value object))))
  125.  
  126. (push (cons "Time optimized slot-value inside of a defmethod (standard)"
  127.         '(time-meth-standard-2-slot-value m 10000))
  128.       *tests*)
  129. (defun time-meth-standard-2-slot-value (object n)
  130.   (time (dotimes (i n) (meth-standard-2-slot-value object))))
  131.  
  132. (push (cons "Time optimized slot-value inside of a defmethod (structure)"
  133.         '(time-meth-structure-1-slot-value str 10000))
  134.       *tests*)
  135. (defun time-meth-structure-1-slot-value (object n)
  136.   (time (dotimes (i n) (meth-structure-1-slot-value object))))
  137.  
  138.  
  139. (defun expand-all-macros (form)
  140.   (walk-form form nil #'(lambda (form context env)
  141.               (if (and (eq context :eval)
  142.                    (consp form)
  143.                    (symbolp (car form))
  144.                    (not (special-form-p (car form)))
  145.                    (macro-function (car form)))
  146.                   (values (macroexpand form env))
  147.                   form))))
  148.  
  149. (push (cons "Macroexpand method-structure-slot-value"
  150.         '(pprint (multiple-value-bind (function optimized-function)
  151.                 (expand-defmethod-internal
  152.                          (prototype-of-generic-function 'meth-structure-slot-value)
  153.                          (method-prototype-for-gf 'meth-structure-slot-value)
  154.                          'method-structure-slot-value
  155.                  nil '((object str))
  156.                  '(#'(lambda () (slot-value object 'slot)))
  157.                  nil)
  158.                        optimized-function)))
  159.       *tests*)
  160. #-kcl
  161. (push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)."
  162.         '(disassemble (meth-structure-slot-value str)))
  163.       *tests*)
  164. (defmethod meth-structure-slot-value ((object str))
  165.   #'(lambda () (slot-value object 'slot)))
  166.  
  167.  
  168. #|| ; interesting, but long.  (produces 100 lines of output)
  169. (push (cons "Macroexpand meth-standard-slot-value"
  170.         '(pprint (expand-all-macros
  171.                        (multiple-value-bind (function optimized-function)
  172.                 (expand-defmethod-internal
  173.                          (prototype-of-generic-function 'meth-standard-slot-value)
  174.                          (method-prototype-for-gf 'meth-standard-slot-value)
  175.                          'meth-standard-slot-value
  176.                  nil '((object standard-method))
  177.                  '(#'(lambda () (slot-value object 'function)))
  178.                  nil)
  179.                        optimized-function))))
  180.       *tests*)
  181. (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)."
  182.         '(disassemble (meth-standard-slot-value m)))
  183.       *tests*)
  184. (defmethod meth-standard-slot-value ((object standard-method))
  185.   #'(lambda () (slot-value object 'function)))
  186. ||#
  187.  
  188.  
  189. (defun do-tests ()
  190.   (dolist (doc+form (reverse *tests*))
  191.     (format t "~&~%~A~%" (car doc+form))    
  192.     (pprint (cdr doc+form))
  193.     (eval (cdr doc+form))))
  194.